(in-package :graph-model)

(defvar *oriented* t)

(defgeneric oriented-p (o))
(defgeneric graph-nodes (graph))
(defgeneric graph-arcs (graph))
(defgeneric graph-marked-nodes (graph))

(defgeneric node-in-arcs (node graph)
  (:documentation "in-going arcs of node"))

(defgeneric graph-edges (g))
(defgeneric node-add-arc (arc))
(defgeneric graph-add-arc (origin extremity weight g))
(defgeneric graph-create-arc (g origin extremity weight oriented))

(defclass oriented-mixin ()
  ((oriented-p :initarg :oriented-p :accessor oriented-p)))

(defclass graph (oriented-mixin)
  ((nodes :initarg :nodes :initform '() :accessor graph-nodes)
   (arcs :initform '() :initarg :arcs :accessor graph-arcs)))

(defun make-graph (&optional (oriented *oriented*))
  (make-instance 'graph :oriented-p oriented))

(defmethod graph-add-node ((node node) (g graph))
  (setf (graph-nodes g) (node-adjoin node (graph-nodes g)))
  node)

(defmethod find-node (num (g graph))
  (find-object-from-num num (graph-nodes g)))

(defmethod graph-create-node ((num integer) (g graph) &optional (label nil))
  (let ((node (if label
		  (make-labeled-node num label)
		  (make-node num))))
    (graph-add-node node g)))

(defmethod find-add-node (num (g graph) &optional (label nil))
  (let ((node (find-node num g)))
    (if node
	(progn (assert (equal (label node) label)) node)
	(graph-create-node num g label))))

(defmethod print-object ((g graph) stream)
  (format stream "~A nodes " (nb-nodes g))
  (format stream "~A arcs " (nb-arcs g))
  (unless (oriented-p g)
    (format stream "not "))
  (format stream "oriented "))

(defmethod name ((g graph)) "graph")

(defmethod graph-marked-nodes ((g graph))
  (remove-if-not #'node-marked-p (graph-nodes g)))

(defmethod graph-unmarked-nodes ((g graph))
  (remove-if #'node-marked-p (graph-nodes g)))

(defmethod nb-nodes ((g graph))
  (length (graph-nodes g)))

(defmethod nb-arcs ((g graph))
  (length (graph-arcs g)))

(defmethod nb-edges ((g graph))
  (length (graph-edges g)))

(defmethod out-degree ((node node) (g graph))
  (length (node-out-arcs node)))

(defmethod in-degree ((node node) (g graph))
  (length (node-in-arcs node g)))

(defmethod connected-arcs ((node node) (g graph))
  (append (node-in-arcs node g) (node-out-arcs node))) ;; no loops!

(defmethod isolated-node-p ((node node) (g graph))
  (and
   (zerop (in-degree node g))
   (zerop (out-degree node g))))

(defmethod graph-isolated-nodes ((g graph))
  (remove-if-not
   (lambda (node)
     (isolated-node-p node g))
   (graph-nodes g)))

(defmethod node-in-arcs ((node node) (g graph))
  (loop
    for arc in (graph-arcs g)
    when (eq node (extremity arc))
      collect arc))

(defmethod mark-node ((node node))
  (mark-object node))

(defmethod unmark-node ((node node))
  (unmark-object node))

(defmethod node-marked-p ((node node))
  (mark node))

(defmethod graph-unmark-all-nodes ((g graph))
  (mapc #'unmark-node (graph-nodes g)))

(defmethod graph-unmark-all-arcs ((g graph))
  (mapc #'unmark-arc (graph-arcs g)))

(defmethod set-nodes-weight ((g graph) &optional (w nil))
  (mapc (lambda (node) (change-weight node w)) (graph-nodes g)))

(defmethod unset-nodes-weight ((g graph))
  (set-nodes-weight g))

(defmethod set-arcs-weight ((g graph) &optional (w nil))
  (mapc (lambda (arc) (change-weight arc w)) (graph-arcs g)))

(defmethod unset-arcs-weight ((g graph))
  (set-arcs-weight g))

(defmethod inverse-arcs-p ((a1 arc) (a2 arc))
  (and (eq (origin a1) (extremity a2))
       (eq (origin a2) (extremity a1))))

(defmethod edges-from-arcs ((arcs list))
  (remove-duplicates arcs :test #'inverse-arcs-p))

(defmethod graph-edges ((g graph))
  (edges-from-arcs (graph-arcs g)))

(defmethod empty-graph-p ((g graph))
  (endp (graph-nodes g)))

(defmethod out-neighbours ((node node) (g graph))
  (mapcar #'extremity (node-out-arcs node)))

(defmethod in-neighbours ((node node) (g graph))
  (mapcar #'origin (node-in-arcs node g)))

(defmethod neighbours ((node node) (g graph))
  (node-union
   (in-neighbours node g)
   (out-neighbours node g)))

(defmethod node-add-arc ((arc arc))
  (let ((node (origin arc)))
    (setf (node-out-arcs node) (my-adjoin arc (node-out-arcs node)))))

(defmethod graph-add-arc ((origin node) (extremity node) weight (g graph))
  (let ((arc (make-arc origin extremity weight)))
    (node-add-arc arc)
    (setf (graph-arcs g) (my-adjoin arc (graph-arcs g)))))

(defmethod graph-create-arc ((g graph) (origin node) (extremity node) weight oriented)
  (assert (node-member origin (graph-nodes g)))
  (assert (node-member extremity (graph-nodes g)))
  (graph-add-arc origin extremity weight g)
  (unless oriented
    (graph-add-arc extremity origin weight g)))


